home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / yerk / mps231ss.hqx / Mops source / Module source / Debugmod.txt < prev    next >
Text File  |  1993-02-06  |  21KB  |  938 lines
  1. \ This module handles decompilation and debugging.
  2.  
  3. \ June 92    - fixed trap handling for user mode / virtual memory.
  4.  
  5. false    value    INMOD?            \ true if we're decompiling/debugging
  6.                     \ a module
  7.     objPtr    THEMOD    class_is  module
  8.                     \ This is the module we're 
  9.                     \  decompiling/debugging
  10.     handle    THEHDL
  11.  
  12.  
  13. :class    MOD-DIC-MARK    super{ dic-mark }
  14.  
  15.     var    MODCXT
  16.     var    CXTOFFS
  17.     var    MODPTR
  18.  
  19. :m DUMP:
  20.     ." modPtr:  "  get: modPtr  .h  cr
  21.     ." modCxt:  "  get: modCxt  .h  cr
  22.     ." cxtOffs: "  get: cxtOffs .h  cr  ;m
  23.  
  24. :m SELECTMOD:    \ ( ^mod -- )
  25.     -> theMod        \ Fails if not a module object pointer
  26.     load: theMod        \ Ensure module is loaded
  27.     handle: theMod  put: theHdl
  28.     nptr: theHdl  put: modPtr
  29.     get: modPtr  size: theHdl  +  32 -
  30.     dup  put: modCxt  4- @  put: cxtOffs  ;m
  31.  
  32. :m SETTOMODTOP:
  33.     #threads for
  34.         get: modCxt
  35.         i  2 <<  +  displace  get: cxtOffs -
  36.         i to: links
  37.     next
  38.     setc: self  ;m
  39.  
  40. :m NEXTINMOD:  { \ lfa -- lfa }
  41.     get: current  at: links
  42.     dup  get: modPtr  <=  IF  drop  0  exit  then
  43.     dup -> lfa
  44.     displace  get: current  to: links
  45.     setc: self  lfa  ;m
  46.  
  47. :m FINDINMOD:  { s255 \ addr len lfa -- cfa T  |  s255 F }
  48.     s255 count  -> len -> addr
  49.     addr len upper
  50.     setToModTop: self
  51.     begin
  52.         nextinMod: self  -> lfa
  53.         lfa nif  s255  false  exit  then
  54.         lfa l>name  n>count  addr len  s=
  55.         if  ( Found it! )
  56.             lfa link>  true  exit
  57.         then
  58.     again  ;m
  59.  
  60. ;class
  61.  
  62. mod-dic-mark  MM
  63.  
  64. : IN
  65.     '  ( module cfa )
  66.     >obj  selectMod: MM  lock: theMod
  67.     true -> inMod?
  68.     theMod use_module  ;
  69.  
  70. : NOTIN
  71.     false -> inMod?  ;
  72.  
  73. : SET_MODBASE        \ Be awfully careful doing this!!
  74.     inMod? IF  base: theMod  32766 +  ELSE  -1  THEN
  75.     -> modbase  ;
  76.  
  77. : @ABSM  { ^rel-addr \ svModbase -- abs-addr }
  78.     modbase -> svModbase  set_modbase
  79.     ^rel-addr  @abs
  80.     svModbase -> modbase  ;
  81.  
  82. : (GET_CFA)  { \ svModbase -- cfa }
  83.     Mword dup c@ over + c@  & :  =
  84.     if  ( method for a class )
  85.         hash  recurse            \ Recursive call to get class
  86.         chkClass
  87.         modbase -> svModbase  set_modbase
  88.         findm  nip
  89.         svModbase -> modbase
  90.     else
  91.         inMod?
  92.         if        \ in a module
  93.             findinmod: MM
  94.             nif  true abort" not found"  then
  95.         else        \ in main dic
  96.             nilP -> theMod
  97.             find  0= abort" not found"
  98.         then
  99.     then  ;
  100.  
  101. : GET_CFA
  102.     (get_cfa)  ( false -> inMod? )  ;
  103.  
  104. \        ========== DECOMPILER ==========
  105.  
  106.     0    value    LOCATION    \ Holds the current address in the parameter
  107.                 \  field of the definition being decompiled.
  108.     0    value    THIS_CFA    \ Holds the current cfa.
  109.     0    value    THAT_CFA    \ Holds the cfa called by current instruction
  110.     2    value    GIN        \ "Go in". Holds the current amount to indent.
  111.    10    value    SAVEBASE    \ Saves the number base.
  112.     0    value    #P        \ Number of named parms/local vars.
  113. false    value    CALL?        \ True if we're processing a call.
  114.     0    value    LAST_OBJ    \ The last object referenced in debugging
  115.  
  116.  
  117. : .LOCN         \ Prints the current value of LOCATION and the value of the
  118.                 \ word there.
  119.     location  6 .r  location w@  5 .r  location 2+ w@  5 .r  ;
  120.  
  121. : DIN           \ "Do indent".  Prints the location and then indents.
  122.     cr .locn  gin spaces
  123.     location  addr>curs drop  ;
  124.  
  125. : NXT>     \ ( -- n )  Fetches the longword where LOCATION points, and
  126.     \           updates LOCATION.
  127.     location w@  2 ++> location  ;
  128.  
  129. : .NO
  130.     dup .  dup  decimal .  hex
  131.     bl & ~  within? if  emit  else  drop  then  ;
  132.  
  133. : .1    1 .r  ;
  134.  
  135. : .D    4 7  within?
  136.     IF  ." parm/loc# "  7 swap -  .1  EXIT  THEN
  137.     dup 3 =  IF  drop  ." i"  EXIT  THEN
  138.     ." D"  .1  ;
  139.  
  140. : .A    case[       5  ]=>  ." MP"
  141.         [  6  ]=>  ." SP"
  142.         [  7  ]=>  ." RP"
  143.         default=>  ." A"  .1
  144.     ]case  ;
  145.         
  146. : STRING?
  147.     that_cfa 2- w@x  -18 =  ;
  148.  
  149. : .NAME  { cfa -- }
  150.     cfa  .id
  151.     call?  0EXIT
  152.     cfa  ['] (defer)  =
  153.     if  4 ++> location  exit  then
  154.     string?
  155.     if    space  & " emit  location count 2dup type  & " emit
  156.         +  align  -> location
  157.     then  ;
  158.     
  159. : ?.PARAMETERS    \ ( cfa -- )  Prints any parameters associated with 
  160.             \   this word.
  161.     drop  ;
  162.  
  163. : ?.VALUE     \ ( cfa -- )  Prints a value or any other useful (?) 
  164.         \  information associated with this word.
  165.     drop  ;
  166.  
  167.  
  168. : .WORD     \ ( cfa -- )  Prints the name of the word with the given cfa.
  169.     ( ?mcf )  dup  .name  dup ?.parameters  ?.value  ;
  170.  
  171. : SHOW_CLASS  { addr \ svModbase -- }
  172.     modbase -> svModbase
  173.     set_modbase
  174.     addr >obj  .class: object
  175.     svModbase -> modbase  ;
  176.  
  177. : ?TYP  { addr -- addr }
  178.     addr 2- w@x
  179.     case[       objCode  ]=>    ." object of type "  addr show_class
  180.         [  valCode  ]=>    ." value "  addr @  .no
  181.         default=>  drop
  182.     ]case  ;
  183.  
  184. local  IDENTIFY?  { \ svModbase op mode reg reg1 disp incr -- b }
  185.  
  186. : GETMODE®
  187.     op  $ 7  and  -> reg
  188.     op  $ 38 and  3 >>  -> mode  ;
  189.  
  190. : GETADDR        \ ( -- addr )
  191.     getMode&Reg
  192.     mode 5 =  nif  0  exit  then    \ If not d(An), just rtn zero
  193.     reg                    \ Reg
  194.     case[       3    ]=>    lobase
  195.         [  4    ]=>    hibase
  196.         [  5    ]=>    theMod nilP <>
  197.             if    base: theMod  32766 +
  198.             else    0
  199.             then
  200.         default=>    drop  0
  201.     ]case
  202.     location w@x  +            \ Add displ
  203.     2 ++> location  ;
  204.  
  205. : d(An)    getAddr
  206.     reg 2 =
  207.     if    ." ivar offs "  .
  208.     else    cfa? if  dup .id space  then  dup  .h  ?typ
  209.     then  ;
  210.  
  211. : TRYLIT
  212.     reg 4 <>  ?exit
  213.     location @  decimal . hex  4 ++> location  ;
  214.  
  215. : .ADDR
  216.     getMode&Reg
  217.     mode
  218.     case[       0  ]=>        reg .d
  219.         [  1  ]=>        reg .a
  220.         [  2  ]=>    ." ("    reg .a  ." )"
  221.         [  3  ]=>    ." ("    reg .a  ." )+"
  222.         [  4  ]=>    ." -("    reg .a  ." )"
  223.         [  5  ]=>    d(An)
  224.         [  7  ]=>    tryLit
  225.         default=>  drop
  226.     ]case  ;
  227.  
  228. : SEE_CASE    ;
  229.  
  230. : DO_JSR
  231.     call?  if  ." JSR "  else  ." JMP "  then
  232.     getAddr  dup -> that_cfa  .name
  233.     that_cfa  ['] (case)  =  if  see_case  then  ;
  234.  
  235. : DO_BSR
  236.     ." BSR "
  237.     op $ FF and  -> disp  0 -> incr
  238.     disp 0=
  239.     if    location w@x  -> disp  2 -> incr
  240.     else    disp  $ 7F > if  $ FFFFFF00  or> disp  then
  241.     then
  242.     disp location +  dup -> that_cfa  .name
  243.     incr ++> location  ;
  244.  
  245. : DO_BCC
  246.     ." BRANCH"
  247.     op  $ FF  and
  248.     nif  2 ++> location  then  ;
  249.  
  250. : DO_LONG#
  251.     location @  .no
  252.     4 ++> location  ;
  253.  
  254. : DO_SHORT#
  255.     op $ FF and  .no
  256.     2 ++> location  ;
  257.  
  258. : DO_LEA
  259.     op  $ E00 and 9 >>  -> reg1
  260.     op  $ 41D2  = if  ." self"  exit  then
  261.     reg1
  262.     nif    getAddr
  263.         reg 2 =
  264.         if      ." ivar offs "  .
  265.         else      ." object "  dup -> last_obj  8 -  .name
  266.         then
  267.     else
  268.         ." LEA  "  .addr  ."   ->  "  reg1 .a
  269.     then  ;
  270.  
  271. : DO_MOVE
  272.     ." MOVE  "  .addr  ."  -> "
  273.     op  3 >>  $ 38 and
  274.     op  9 >>  $  7 and  or  -> op  .addr  ;
  275.  
  276. : 1OP        \ ( addr len )
  277.     type  2 spaces  .addr  ;
  278.  
  279. : DO_ADDQ
  280.     op  $ 100 and  nif  ." ADDQ #"  else  ." SUBQ #"  then
  281.     op  9 >>  7 and
  282.     dup nif  drop 8  then  .
  283.     ." ,"  .addr  ;
  284.  
  285. : DO_MOVEM
  286.     op  $ FF00 and  $ 4800 =
  287.     if    ." MOVEM  regs,"  .addr
  288.     else    ." MOVEM  "  .addr  ." ,regs
  289.     then
  290.     2 ++> location  ;
  291.  
  292. : DO_+ETC
  293.     op  $ F000  and
  294.     case[       $ D000    ]=>    ." ADD  "    true
  295.         [  $ 9000    ]=>    ." SUB  "    true
  296.         [  $ C000    ]=>    ." AND  "    true
  297.         [  $ 8000    ]=>    ." OR  "    true
  298.         [  $ B000    ]=>    op $ 100 and
  299.                 if ." XOR  " else ." CMP  " then   true
  300.         default=>    drop  ." trap "  op .h  false
  301.     ]case
  302.     0exit
  303.     op 9 >> 7 and  -> reg1
  304.     op  $ 100 and
  305.     if    reg1 .d  ."  -> "  .addr
  306.     else    .addr  ."  -> "  reg1 .d
  307.     then  ;
  308.  
  309. : DO_IMM
  310.     op  8 >>  $ F  and
  311.     case[       0  ]=>    ." OR"
  312.         [  2  ]=>    ." AND"
  313.         [  4  ]=>    ." SUB"
  314.         [  6  ]=>    ." ADD"
  315.         [ $ A ]=>    ." XOR"
  316.         default=>    " ???"
  317.     ]case
  318.     op 6 >> 3 and
  319.     case[      0 ]=>    ." .B  "  location w@x  2 ++> location
  320.         [ 1 ]=>    ." .W  "  location w@x  2 ++> location
  321.         default=>    ." .L  "  location  @   4 ++> location
  322.     ]case
  323.     ." #"  .h  ."  -> "  .addr  ;
  324.  
  325. :loc IDENTIFY?
  326.     set: fWind        \ Just in case
  327.     true
  328.     location w@  -> op  2 ++> location
  329.     false -> call?  0 -> that_cfa
  330.  
  331.     op  $ FFC0 and  $ 4E80 =    if  true -> call?  do_jsr
  332.                             exit  then
  333.     op  $ FFC0 and  $ 4EC0 =   ( JMP)  if  do_jsr    exit  then
  334.     op  $ FF00 and  $ 6100 =    if  true -> call?  do_bsr
  335.                             exit  then
  336.     op  $ F000 and  $ 6000 =    if  do_bcc    exit  then
  337.     op  $ 29BC  =            if  do_long#    exit  then
  338.     op  $ FF00 and  $ 7400 =    if  do_short#    exit  then
  339.     op  $ 2D16 =            if  ." DUP"    exit  then
  340.     op  $ F000 and  $ 2000 =    if  do_move    exit  then
  341.     op  $ 4E75  =            if  ." EXIT"    exit  then
  342.     op  $ 588E  =            if  ." DROP"    exit  then
  343.     op  $ F000 and  $ 5000 =    if  do_addq    exit  then
  344.     op  $ F1C0 and  $ 41C0 =    if  do_lea    exit  then
  345.     op  $ FF00 and  dup  $ 4800 =  swap  $ 4C00 =  or
  346.                     if  do_movem    exit  then
  347.     op  12 >>  8  $ D  within? nip  if   do_+etc    exit  then
  348.     op  $ F000 and            nif do_imm    exit  then
  349.     op  $ FF00 and
  350.     case[        $ 4200    ]=>    " CLR"  1op
  351.         [    $ 4A00    ]=>    " TST"  1op
  352.             default=>    2drop  false
  353.     ]case
  354. ;loc
  355.     
  356.  
  357. : .INST        \ Decompiles the next instruction in the current definition.
  358.     din
  359.     identify? drop  ;
  360.  
  361.  
  362.     0    value    CL_DEPTH
  363.  
  364. : CRI        \ CR plus indent
  365.     cr  cl_depth 2+  spaces  ;
  366.  
  367. getSelect PRINT:        constant   printID
  368.  
  369. : .IVLIST  { ^obj ^class \ svModbase thisivar ioffs ^cl -- }
  370.     ^class ifa displace  -> thisivar
  371.     begin
  372.         thisivar @ 0>
  373.         if            \ Traverse n-way for superclasses
  374.             begin    thisivar @  0exit
  375.                 thisivar @absM -> ^cl
  376.                 cri  ." superclass "
  377.                 ^cl .id
  378.                 ^cl  ['] object  =
  379.                 nif    2 ++> cl_depth
  380.                     ^obj ^cl  recurse
  381.                     2 --> cl_depth
  382.                 then
  383.                 4 ++> thisivar
  384.             again
  385.         else            \ Ordinary ivar
  386.             thisivar 8 + @absM  -> ^cl
  387.             cri thisivar 12 + w@ -> ioffs
  388.             ." ivar offset "  ioffs .
  389.             ^cl  ['] object  =
  390.             if    ."    (bytes)"
  391.             else    ." class "  ^cl .id  2 spaces
  392.                 ^obj ioffs +  printID ^cl
  393.                 modbase -> svModbase  set_modbase
  394.                 findm
  395.                 svModbase -> modbase
  396.                 >r + r>  ex-method
  397.             then
  398.             thisivar 4+ displace  -> thisivar
  399.         then
  400.     again  ;
  401.  
  402. : .SUPERS  { ^class \ svModbase thisivar ^cl -- }
  403.  
  404. \ This code is similar to .IVARS above, since we find the superclasses by traversing the ivar chain to find the n-way for the supers.  But of course we don't print any ivar information.
  405.  
  406.     ^class ifa displace  -> thisivar
  407.     begin
  408.         thisivar @ 0>
  409.         if            \ Traverse n-way for superclasses
  410.             begin    thisivar @  0exit
  411.                 thisivar @absM -> ^cl
  412.                 cri  ." superclass "
  413.                 ^cl .id
  414.                 ^cl  ['] object  =
  415.                 nif    2 ++> cl_depth
  416.                     ^cl  recurse
  417.                     2 --> cl_depth
  418.                 then
  419.                 4 ++> thisivar
  420.             again
  421.         else            \ Ordinary ivar
  422.             thisivar 8 + @absM  -> ^cl
  423.             thisivar 4+ displace  -> thisivar
  424.         then
  425.     again  ;
  426.  
  427. ' null    vect    VV
  428.  
  429. local .WHATEVER  { cfa \ ^obj svModbase -- b }
  430.  
  431. : .OBJECT
  432.     cfa ?typ  2 spaces
  433.     modbase -> svModbase  set_modbase
  434.     cfa >obj -> ^obj        \ Note: we've altered modbase, but
  435.     print: ^obj            \ it's OK here since none of these
  436.     ^obj dup >class        \ words are local to this module.
  437.     svModbase -> modbase
  438.     0 -> cl_depth
  439.     .ivlist  ;
  440.  
  441. : .CLASS
  442.     ." Class "  cfa  dup  .id  .supers  ;
  443.  
  444. : .DEFN    ;
  445.  
  446. : .VALUE        cfa ?typ  ;
  447.  
  448. : .VECT
  449.     ." Vect -> "
  450.     4 ++> cfa            \ Step past JSR doVect
  451.     cfa @ nif
  452.         4 ++> cfa  ." default: "
  453.         location  cfa -> location  identify? drop  -> location
  454.     else    cfa @abs  .id
  455.     then  ;
  456.  
  457.  
  458. :loc .WHATEVER        \ { cfa -- b }
  459.     cfa 2- w@x
  460.     case[       objcode            ]=>  .object  false
  461.         [  classcode            ]=>  .class   false
  462.         [  ' .inst    2 - w@x    ]=>  .defn    true
  463.         [  ' location 2 - w@x    ]=>  .value   false
  464.         [  ' vv       2 - w@x    ]=>  .vect    false
  465.         default=> ." ???"  drop  false
  466.     ]case
  467. ;loc
  468.  
  469. : START  { cfa \ ok? -- ok? }    \ Sets things up for a new decompilation.
  470.                                 \   Returns true if we are to continue.
  471.     true -> ok?
  472.     cfa -> location
  473. \    location  locate_src
  474.     2 ++> gin  din
  475.     ." : "  cfa dup .id  >name  c@ 64 and if ."  IMMEDIATE"  then
  476.     ok?
  477.     if    cfa  -> location
  478.     else  ( back to where we were )
  479.         -> location  -2 ++> gin
  480.     then
  481.     ok?  ;  
  482.  
  483. : FINISH
  484.     -2 ++> gin
  485.     gin if  location locate_src  then  ;
  486.  
  487. : DONE?   ( -- b )
  488.     location w@  $ 4E75  =
  489.     drop false  ;
  490.  
  491.  
  492. : (SEE)  { cfa \ svBase svLocation next? stop? -- }
  493.             \ Exported.  Decompiles the word with the given cfa.
  494.     base -> svbase  hex
  495.     cfa locate_src
  496.     cfa .whatever  IF  cfa start  ELSE  false  THEN
  497.     NIF  svbase -> base  EXIT  THEN
  498.     location @ -> this_cfa  .inst
  499.     BEGIN
  500.         true -> next?  false -> stop?    \ Do it unless we find out 
  501.                         \  otherwise
  502.         key  & a  & z  within? if  bl -  then
  503.         case[      & Q    ]=>  sp0 sp!  svbase -> base
  504.                     notin cl  cr  quit
  505.             [  13    ]=>  location -> svLocation
  506.                 that_cfa  if  2 spaces  that_cfa  (see)  then
  507.                     svLocation -> location
  508.             [ & U    ]=>  true -> stop?  false -> next?
  509.             [ & 2    ]=>  2 ++> location
  510.             [ & P    ]=>  8 --> location
  511.             [ $ 1E    ]=>  1up  false -> next?
  512.             [ $ 1F    ]=>  1dn  false -> next?
  513.             [ $ 1C    ]=>  1Lft false -> next?
  514.             [ $ 1D    ]=>  1rt  false -> next?
  515.             [ $ 37    ]=>  home false -> next?
  516.             [ $ 31    ]=>  end  false -> next?
  517.             [ $ 39    ]=>  defnUp  false -> next?
  518.             [ $ 33    ]=>  defnDn  false -> next?
  519.             default=>  drop
  520.         ]case
  521.         next? if  location @ -> this_cfa  .inst  then
  522.         done? stop? or
  523.     until
  524.      ( Show last word )  next? if  .inst  then  finish
  525.     svbase -> base  ;
  526.  
  527.  
  528. : SEE    0 -> gin  get_cfa  (see)  ;
  529.  
  530.  
  531. \            =======  DEBUGGER  =======
  532.  
  533.  
  534.      variable    PROGREGS    64 allot
  535.  
  536.     0    value    CURRMODBASE
  537.  
  538.    10    array    PCSTK
  539.     0    value    PC#
  540.  
  541.     0    value    PC            \ Current user PC on brkpt or trace trap
  542.     0    value    STATUS            \ Current user status word ditto
  543.  
  544.     0    value    BP            \ Current breakpoint address
  545.     0    value    BPCONT            \ Contents of that location
  546.  
  547.     0    value    IBP            \ Initial breakpoint address
  548.     0    value    IBPCONT        \ Contents
  549.  
  550.     0    value    TTRAPVAL        \ Original contents of T trap vector
  551.  
  552. false    value    DONE?
  553. false    value    GETOUT?
  554. false    value    INITIALIZED?
  555. false    value    IN_CASE?
  556. false    value    DEBUG_STARTED?
  557.  
  558.  
  559. : PUSHPC        PC# to: PCstk  1 ++> PC#  ;
  560.  
  561. : POPPC        -1 ++> PC#  PC# at: PCstk  ;
  562.  
  563. : BPON        \ ( addr -- )
  564.     -> BP
  565.     BP w@  -> BPcont
  566.     $ 4E40  BP w!  patches_done  ;
  567.  
  568. : BPOFF        BPcont  BP w!  patches_done  ;
  569.  
  570. :code TOPROG    \ Returns to the user prog with tracing off.
  571.     loc
  572.     movem    dic[progRegs],d0-d7/a0-a6
  573.     move.l    rel[PC],-(a7)   ; A5 won't be right for debugmod
  574.     move.w    2(rel[status]),ccr
  575.     rts
  576. ;code
  577.  
  578.  
  579. : UP        \ End tracing current definition; resume next level up.
  580.     PC# if    cr ." *** going up ***"
  581.         popPC  BPon  true -> getout?
  582.     else    cr ." *** at top already - maybe do a G instead? ****
  583.     then  ;
  584.  
  585. : DOWN
  586.     cr ." *** going down ***"
  587.     location  pushPC  ;
  588.  
  589.  
  590. : X    (lit-str) 99 ;        \ A dummy definition - not executed
  591.  
  592. : STEP_CASE
  593.     true -> in_case?  ;    \ Inhibits display till we get into the stub
  594.  
  595. : NXT_CASE    \ ( -- b )
  596.     location w@  $ 4ED1 =
  597.     if  cr ." *** doing CASE[ selection:"  false  exit  then
  598.     location w@  $ 4EF0 =
  599.     if  cr ." *** doing SELECT{ selection:"  false  exit  then
  600.     true  ;
  601.  
  602. : STEP
  603.     call?  0exit        \ If not a call, continue normal trace
  604.     that_cfa
  605.     case[      ' @(ip)    ]=>    4 ++> location  true
  606.         [ ' w@(ip)    ]=>    2 ++> location  true
  607.         [ ' (case) ], [ ' (sel) ]=>    step_case  false
  608.         default=>    drop  true
  609.     ]case
  610.     0exit
  611.     location  BPon  true -> getout?  ;
  612.  
  613. : .DEPTH
  614.     ."   (" depth 2 .r  ." )"  ;
  615.  
  616. : .STK  { \ svCurs -- }
  617.     depth  0<=  ?exit
  618.     curs -> svCurs  -curs  20 out -  spaces
  619.     0  depth 4 min  2-
  620.     do
  621.         i pick  8 .r
  622.     -1 +loop
  623.     svCurs -> curs  ;
  624.  
  625. : .RG    \ ( addr -- )
  626.     @ 0  <#  # # # # # # # #  #>  type  ;
  627.  
  628. : .D&A  { cnt -- }
  629.     & D emit  cnt .  3 spaces
  630.     cnt 4* progRegs +  dup  .rg  10 spaces  32 +
  631.     & A emit  cnt .  3 spaces
  632.     .rg  ;
  633.  
  634. : .REGS
  635.     base  hex
  636.     8 0 do   cr  i  .d&a   loop
  637.     -> base  ;
  638.  
  639.  
  640. false    value    RES?
  641.  
  642. : *OK    & * emit  ok  ;
  643.  
  644. : DO_F  { \ svState svCurs -- }
  645.     cr OK  state -> svState  curs -> svCurs  +curs
  646.     begin    0 -> state  false -> res?
  647.         query  interpret  *OK
  648.         res?
  649.     until
  650.     svState -> state  svCurs -> curs  ;
  651.  
  652. : RESUME
  653.     true -> res?  ;
  654.  
  655. : UNBUG
  656.     initialized?  0exit
  657.     notin  cl
  658.     BPoff  TtrapVal if  TtrapVal  $ 24  !  then
  659.     false -> initialized?
  660.     drop: debugmod  ;
  661.  
  662.  
  663. ' null vect    SHOWME
  664.  
  665. : SHOW        \ ( cfa -- )
  666.     -> showme  ;
  667.  
  668. local  DISPLAY  { \ svBase svCurs svLoc next? reDisp? -- }
  669.  
  670. : DISP1
  671.     cr  0 -> out  -curs
  672.     .locn  2 spaces  identify?  drop
  673.     40 out -  dup 0<
  674.     IF  drop  cr  0 -> out  40  then  spaces
  675.     .depth  .stk  
  676.     begin
  677.         true -> next?  false -> reDisp?
  678.         key  & a  & z  within? if  bl -  then
  679.         case[      & N    ]=>  true -> done?
  680.                     BPoff
  681.                     iBP -> BP  iBPcont -> BPcont
  682.             [ & G    ]=>  true -> done?  true -> getout?
  683.                     BPoff TtrapVal  $ 24  !
  684.                     cr decimal  svCurs -> curs
  685.             [ & Q    ]=>    cr  decimal  svCurs -> curs
  686.                     unbug  quit
  687.             [ & F    ]=>  do_F
  688.                     true -> reDisp?  svLoc -> location
  689.             [ & R    ]=>  .regs  false -> next?
  690.             [ & O    ]=>  last_obj ?dup
  691.                     if  dump: **  then
  692.                     false -> next?
  693.             [ & S    ]=>  showme  false -> next?
  694.             [ 13 ],  [ & D ]=>       down
  695.             [ & U    ]=>  up
  696.             [ $ 1E    ]=>  1up  false -> next?
  697.             [ $ 1F    ]=>  1dn  false -> next?
  698.             [ $ 1C    ]=>  1Lft false -> next?
  699.             [ $ 1D    ]=>  1rt  false -> next?
  700.             [ $ 37    ]=>  home false -> next?
  701.             [ $ 31    ]=>  end  false -> next?
  702.             [ $ 39    ]=>  defnUp  false -> next?
  703.             [ $ 33    ]=>  defnDn  false -> next?
  704.             default=>  drop  step
  705.         ]case
  706.         next?
  707.     until  ;
  708.  
  709.  
  710. :loc DISPLAY    \ { \ svBase svCurs svLoc next? reDisp? -- }
  711.     debug_started?
  712.     nif  selectDW  select: fWind  true -> debug_started?  then
  713.     in_case?
  714.     if    nxt_case  dup -> in_case?  exit
  715.     then
  716.     base -> svBase  hex  curs -> svCurs  -curs
  717.     false -> done?  false -> getout?
  718.     location -> svLoc
  719.     location  addr>curs drop
  720.     begin    location @  -> this_cfa
  721.         disp1
  722.         reDisp?
  723.     nuntil  ;loc
  724.  
  725. :code  FIXMODE
  726.     move    A5,dic[tempA5]
  727.     move    rel[currModbase],A5
  728.     movem    d0-d7/a0-a6,dic[progRegs]
  729.     move    dic[tempA5],52(dic[progRegs])
  730.     move.l    6(a7),dic[PC]
  731.     move.w    4(a7),2(dic[status])
  732.     move.l    (a7)+,2(a7)
  733.     bclr    #7,(a7)
  734.     rte
  735. ;code
  736.  
  737. :code  BPTLOC    \ We come here on a breakpoint trap
  738.     bsr    rel[fixMode]
  739.     subq    #2,dic[PC]    ; Replace instrn at bkpt and
  740.     move    dic[PC],a0    ; don't forget to execute it!
  741.     move.w    2(dic[BPcont]),(a0)
  742.     jsr    dic[patches_done]
  743.     move    a0,dic[location]    ; This is location for display
  744.     bsr    dic[display]    ; display everything
  745.     dc.w    $4E42    ; TRAP 2 to set T bit & rtn
  746. ;code
  747.  
  748. :code TRACELOC
  749.     bsr    rel[fixMode]
  750.     tst    dic[done?]
  751.     bne.s    done
  752.     move    dic[PC],dic[location]   ; Next instrn is locn for displ
  753.     bsr    dic[display]
  754.     tst    dic[getout?]
  755.     bne    dic[toProg]
  756.     dc.w    $4E42    ; TRAP 2 to set T bit & rtn
  757.  
  758. done    jsr    dic[cr]    ; DONE? set - we're handling
  759.     move.l    #10,dic[base]    ;  it the next time in, so
  760.     move    dic[BP],a0    ;  the BP gets replaced.
  761.     move.w    #$4E40,(a0)    ; Replace BP for next time
  762.     jsr    dic[patches_done]
  763.     bra    dic[toProg]
  764. ;code
  765.  
  766. :code  TON        \ Returns to user's prog with tracing on.
  767.         \ We set the TRAP 2 vector pointing here, since
  768.         \ we need to be in supervisor mode to set the T bit.
  769.     movem    dic[progRegs],d0-d7/a0-a6
  770.     move.l    rel[PC],2(a7)
  771.     move.w    2(rel[status]),(a7)
  772.     bset    #7,(a7)
  773.     rte
  774. ;code
  775.  
  776.  
  777. : DEBUG        \ Exported.
  778.     0 -> PC#  false -> debug_started?
  779.     get_cfa  dup  locate_src
  780.     initialized?
  781.     nif    lock: debugMod        \ We must be locked since we'll
  782.         modbase -> currModbase    \  be called from a trap
  783.         ['] bptLoc  $ 80 !    \ We use TRAP #0 as our debug brkpt
  784.         ['] Ton     $ 88 !    \ We use TRAP #2 to turn T bit on
  785.         $ 24 @  -> TtrapVal    \ Save T trap vector (-> Macsbug?)
  786.         ['] traceLoc  $ 24 !    \ and set it to our routine TraceLoc
  787.         true -> initialized?
  788.     then
  789.     ( cfa )  BPon
  790.     BP -> iBP  BPcont -> iBPcont        \ Save initial BP details
  791. ;
  792.  
  793. \            ========  PROFILER  =========
  794.  
  795.     0    value    LINECNT
  796.     0    value    PRFPTR
  797.     0    value    LAST_PRFPTR
  798.     0    value    SRC_POS
  799.     0    value    SRC_LIM
  800.  
  801.     string+  $PRF
  802.     string+  $SRC
  803.  
  804.  
  805. : ADDR>PRF  { addr \ offs -- }
  806.     addr filestart_dp -  -> offs
  807.     reset: $prf
  808.     BEGIN
  809.         len: $prf  0<=  ?EXIT
  810.         ^1st: $prf  w@  offs =  ?EXIT        \ If found
  811.         14 skip: $prf  1 ++> lineCnt
  812.     AGAIN  ;
  813.  
  814.  
  815. : FIND_DEFN_START  { addr -- }
  816.     0 -> lineCnt
  817.     addr  addr>prf
  818.     <step: $prf  delete: $prf
  819.     addr  addr>curs  dup >pos: $src  >lim: $src  ;
  820.  
  821. : FIND_DEFN_END  { \ offs addr -- }
  822.     reset: $prf  len: $prf  0EXIT
  823.     ^1st: $prf  w@  -> offs        \ Initial offset
  824.     14 skip: $prf            \ Skip line where defn starts
  825.     BEGIN
  826.         len: $prf  0EXIT
  827.         ^1st: $prf  -> addr
  828.         addr w@  offs  >
  829.         IF  addr w@ -> offs  ELSE  true  addr 5 + c!  THEN
  830.         addr 4+ c@  ?EXIT
  831.         14 skip: $prf
  832.     AGAIN  ;
  833.  
  834.  
  835. : COUNT_THIS  { addr -- }
  836.     addr addr>prf  ^1st: $prf  -> prfPtr
  837.     len: $prf  0EXIT
  838.     prfPtr 2+ w@  addr w!        \ Replace instruction at breakpoint
  839.     patches_done
  840.     1  prfPtr 6 +  +!        \ Increment execution count
  841.     last_time            \ Increment time
  842.     IF    now last_time -  last_prfPtr 10 +  +!
  843.     THEN
  844.     prfPtr -> last_prfPtr  ;
  845.  
  846.  
  847. :code PRFLOC        \ We come here on a profile trap
  848.     push    glob[ticks]
  849.     move    A5,dic[tempA5]
  850.     move    rel[currModbase],A5
  851.     pop    dic[now]
  852.     movem    d0-d7/a0-a6,dic[progRegs]
  853.     move    dic[tempA5],52(dic[progRegs])
  854.     move.l    2(a7),dic[PC]
  855.     move.w    (a7),2(dic[status])
  856.     lea    continue,a0
  857.     move.l    a0,2(a7)
  858.     bclr    #7,(a7)
  859.     rte
  860.  
  861. continue    subq    #2,dic[PC]
  862.     move    dic[PC],a0
  863.     move    a0,dic[this_BP]
  864.     push    a0
  865.     bsr    dic[count_this]
  866. \    lea    dic[prfloc],a0
  867. \    move    a0,$24
  868.     dc.w    $4E42            ; TRAP 2 to set T bit & rtn
  869. ;code
  870.  
  871. :code PRFTRACE        ; Now we've executed the inst at bkpt
  872.     bsr    rel[fixMode]
  873. \    move    dic[ttrapval],$24
  874. \    call    debugger
  875.     move    dic[this_BP],a0
  876.     move.w    #$4E41,(a0)
  877.     jsr    dic[patches_done]
  878.     movem    dic[progRegs],D0-D7/A0-A6
  879.     move.l    rel[PC],-(a7)        ; Set up for RTS
  880.     move.l    glob[ticks],dic[last_time]
  881.     move.w    2(rel[status]),ccr
  882.     rts
  883. ;code
  884.  
  885.  
  886. : SET_BRKPTS  { \ addr -- }
  887.     reset: $prf
  888.     BEGIN
  889.         len: $prf  NIF  patches_done  EXIT  THEN
  890.         ^1st: $prf  5 + c@
  891.         NIF
  892.             ^1st: $prf w@  filestart_dp +  -> addr
  893.             addr w@  ^1st: $prf 2+ w!
  894.             $ 4E41  addr w!
  895.         THEN
  896.         14 skip: $prf
  897.     AGAIN  ;
  898.  
  899. : PROFILE  { \ cfa -- }
  900.     lock: debugMod            \ We'll be entering via traps!
  901.     modbase -> currModbase
  902.     ['] prfLoc  $ 84 !        \ We use TRAP #1 as our profile brkpt
  903.     $ 24 @  -> TtrapVal        \ Save T-bit trap vector
  904.     ['] prfTrace  $ 24 !        \ and reset it to point to PrfTrace
  905.     ['] Ton       $ 88 !        \ We use TRAP #2 to turn T bit on
  906.     true -> initialized?
  907.     get_cfa -> cfa   cfa locate_src
  908.     prof_str  ->: $src  ->: $prf
  909.     size: $prf  0= ?error 188    \ No log file found - needed for profile
  910.     cfa  find_defn_start
  911.     find_defn_end
  912.     delete: $prf
  913.     set_brkpts
  914.     reset: $prf  lock: $prf  ;
  915.  
  916.  
  917. : SHOWP  { \ addr loc -- }
  918.     reset: $prf  cl  bg
  919.     ."   exec   ticks"  cr 0 -> out
  920.     BEGIN
  921.         len: $prf
  922.     WHILE
  923.         ^1st: $prf  -> addr
  924.         addr 5 + c@
  925.         NIF
  926.             addr w@  filestart_dp +  -> loc
  927.             addr 2+ w@  loc w!
  928.             addr  6 + @  ?dup
  929.             IF
  930.                 6 .r  addr 10 + @  8 .r
  931.             THEN
  932.         THEN
  933.         18 out -  spaces
  934.         nextline?: $src  IF  get: $src  type  cr  0 -> out  THEN
  935.         14 skip: $prf
  936.     REPEAT
  937.     unbug  ;
  938.